{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------
-- |
-- Maintainer  :  2LT Team
--
-- Basic definitions for two-level transformation rules
--
-----------------------------------------------------------------------------

module Data.Transform.Rule (

    module Data.Transform.Rule,
    module Data.Transform.Type

  ) where

import Data.Transform.Type

import Data.Set as Set
import Data.Map as Map

-----------------------------------------------------------------------------
-- * Encapsulation of type-changing transformations

-- | Pairs of bi-directional value-level data transformation functions.
data Rep a b = Rep {to :: PF (a -> b), from :: PF (b -> a)}


-- | The View constructor expreses that a type a can be represented by
--   a type b, as witnessed by value-level functions that convert 
--   between these types. Note that the target type does not escape, 
--   which means that it is implicitly existentially qualified.
data View a where
    View :: Rep a b -> Type b -> View (Type a)

getType :: View a -> DynType
getType (View _ t) = DynType t

-- | Type-changing rewrite rules.
type Rule = forall a . Type a -> Maybe (View (Type a))

-----------------------------------------------------------------------------
-- * Printing

instance Show (View a) where
    show (View _ b) = "(View (Rep <to> <from>) "++(show b)++")"

-- | Print the string representation of the target type encapsulated in a view.
showType :: View a -> String
showType (View _ b) = show b

-----------------------------------------------------------------------------
-- * Unleashing composed data migration functions

-- | Apply the forward value-level function masked by a view.
forth :: View (Type a) -> Type b -> a -> Maybe b
forth (View rep tb') tb a = do {Eq <- teq tb tb'; return (eval (to rep) a)}

-- | Apply the backward value-level function masked by a view.
back :: View (Type a) -> Type b -> b -> Maybe a
back (View rep tb') tb b = do {Eq <- teq tb tb'; return (eval (from rep) b)}

-- | Take the representations of forward and backward value-level 
--   functions out of a view.
unView :: View (Type a) -> Type b -> Maybe (PF (a->b), PF (b->a))
unView (View (Rep to fro) tb') tb = do
  Eq <- teq tb tb'
  return (to,fro)

-- | Variation on 'forth' that does not need static knowledge of the
--   target type, and produces a dynamically typed value instead.
forthDyn :: View (Type a) -> a -> Maybe Dynamic
forthDyn (View rep b) x = return (Dyn b (eval (to rep) x))

-- | Variation on 'back' that does not need static knowledge of the
--   original type, and produces a dynamically typed value instead.
backDyn :: View (Type a) -> Dynamic -> Maybe a
backDyn (View rep b) (Dyn c x) = do
  Eq <- teq b c
  return (eval (from rep) x)

-----------------------------------------------------------------------------
-- * Basic representation-abstraction pairs

idrep :: Rep a a
idrep = Rep {to = ID, from = ID}

comprep :: Type b -> Rep a b -> Rep b c -> Rep a c
comprep b f g = Rep {from = COMP b (from f) (from g), to = COMP b (to g) (to f)}

prodmaprep :: Rep a b -> Rep c d -> Rep (a,c) (b,d)
prodmaprep f g = Rep {to = PROD (to f) (to g), from = PROD (from f) (from g)}

summaprep :: Rep a b -> Rep c d -> Rep (Either a c) (Either b d)
summaprep f g = Rep {to = SUM (to f) (to g), from = SUM (from f) (from g)}

listmaprep :: Rep a b -> Rep [a] [b]
listmaprep f = Rep {to = LIST (to f), from = LIST (from f)}

setmaprep :: Rep a b -> Rep (Set a) (Set b)
setmaprep f = Rep {to = SET (to f), from = SET (from f)}

mapmaprep :: Rep b c -> Rep (Map a b) (Map a c)
mapmaprep f = Rep {to = MAP (to f), from = MAP (from f)}

mapkeysrep :: Rep a b -> Rep (Map a c) (Map b c)
mapkeysrep f = Rep {to = MAPKEYS (to f), from = MAPKEYS (from f)}


-----------------------------------------------------------------------------


{-
class RULE r where
  nopp :: r
  (>>>>) :: r -> r -> r
-}